home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue44 / comcorn / AutoEvents / CliMain.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1999-03-01  |  4.6 KB  |  183 lines
  1. unit CliMain;
  2.  
  3. interface
  4.  
  5. uses
  6.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  7.   StdCtrls, Server_TLB, ComObj;
  8.  
  9. type
  10.   TEventSink = class;
  11.  
  12.   TMainForm = class(TForm)
  13.     SendButton: TButton;
  14.     CloseButton: TButton;
  15.     ClearButton: TButton;
  16.     Edit: TEdit;
  17.     Memo: TMemo;
  18.     procedure FormCreate(Sender: TObject);
  19.     procedure SendButtonClick(Sender: TObject);
  20.     procedure ClearButtonClick(Sender: TObject);
  21.     procedure CloseButtonClick(Sender: TObject);
  22.     procedure FormDestroy(Sender: TObject);
  23.   private
  24.     { Private declarations }
  25.     FServer: IServerWithEvents;
  26.     FEventSink: TEventSink;
  27.     FCookie: Integer;
  28.     procedure OnServerMemoChanged(const NewText: string);
  29.     procedure OnClear;
  30.   public
  31.     { Public declarations }
  32.   end;
  33.  
  34.   TEventSink = class(TObject, IUnknown, IDispatch)
  35.   private
  36.     FController: TMainForm;
  37.     { IUnknown }
  38.     function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
  39.     function _AddRef: Integer; stdcall;
  40.     function _Release: Integer; stdcall;
  41.     { IDispatch }
  42.     function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
  43.     function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
  44.     function GetIDsOfNames(const IID: TGUID; Names: Pointer;
  45.       NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
  46.     function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  47.       Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
  48.   public
  49.     constructor Create(Controller: TMainForm);
  50.   end;
  51.  
  52. var
  53.   MainForm: TMainForm;
  54.  
  55. implementation
  56.  
  57. uses ActiveX;
  58.  
  59. {$R *.DFM}
  60.  
  61. { TMainForm }
  62.  
  63. procedure TMainForm.FormCreate(Sender: TObject);
  64. var
  65.   ActiveObj: IUnknown;
  66. begin
  67.   // Get active object if it's available, or create anew if not
  68.   GetActiveObject(Class_ServerWithEvents, nil, ActiveObj);
  69.   if ActiveObj <> nil then FServer := ActiveObj as IServerWithEvents
  70.   else FServer := CoServerWithEvents.Create;
  71.   FEventSink := TEventSink.Create(Self);
  72.   InterfaceConnect(FServer, IServerWithEventsEvents, FEventSink, FCookie);
  73. end;
  74.  
  75. procedure TMainForm.FormDestroy(Sender: TObject);
  76. begin
  77.   InterfaceDisconnect(FEventSink, IServerWithEventsEvents, FCookie);
  78.   FEventSink.Free;
  79. end;
  80.  
  81. procedure TMainForm.SendButtonClick(Sender: TObject);
  82. begin
  83.   FServer.AddText(Edit.Text);
  84. end;
  85.  
  86. procedure TMainForm.ClearButtonClick(Sender: TObject);
  87. begin
  88.   FServer.Clear;
  89. end;
  90.  
  91. procedure TMainForm.CloseButtonClick(Sender: TObject);
  92. begin
  93.   Close;
  94. end;
  95.  
  96. procedure TMainForm.OnServerMemoChanged(const NewText: string);
  97. begin
  98.   Memo.Text := NewText;
  99. end;
  100.  
  101. procedure TMainForm.OnClear;
  102. begin
  103.   Memo.Clear;
  104. end;
  105.  
  106. { TEventSink }
  107.  
  108. constructor TEventSink.Create(Controller: TMainForm);
  109. begin
  110.   FController := Controller;
  111.   inherited Create;
  112. end;
  113.  
  114. { TEventSink.IUnknown }
  115.  
  116. function TEventSink._AddRef: Integer;
  117. begin
  118.   // No need to implement, since lifetime is tied to client
  119.   Result := 1;
  120. end;
  121.  
  122. function TEventSink._Release: Integer;
  123. begin
  124.   // No need to implement, since lifetime is tied to client
  125.   Result := 1;
  126. end;
  127.  
  128. function TEventSink.QueryInterface(const IID: TGUID; out Obj): HResult;
  129. begin
  130.   // First look for my own implementation of an interface
  131.   // (I implement IUnknown and IDispatch).
  132.   if GetInterface(IID, Obj) then
  133.     Result := S_OK
  134.   // Next, if they are looking for outgoing interface, recurse to return
  135.   // our IDispatch pointer.
  136.   else if IsEqualIID(IID, IServerWithEventsEvents) then
  137.     Result := QueryInterface(IDispatch, Obj)
  138.   // For everything else, return an error.
  139.   else
  140.     Result := E_NOINTERFACE;
  141. end;
  142.  
  143. { TEventSink.IDispatch }
  144.  
  145. function TEventSink.GetIDsOfNames(const IID: TGUID; Names: Pointer;
  146.   NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
  147. begin
  148.   Result := E_NOTIMPL;
  149. end;
  150.  
  151. function TEventSink.GetTypeInfo(Index, LocaleID: Integer;
  152.   out TypeInfo): HResult;
  153. begin
  154.   Pointer(TypeInfo) := nil;
  155.   Result := E_NOTIMPL;
  156. end;
  157.  
  158. function TEventSink.GetTypeInfoCount(out Count: Integer): HResult;
  159. begin
  160.   Count := 0;
  161.   Result := S_OK;
  162. end;
  163.  
  164. function TEventSink.Invoke(DispID: Integer; const IID: TGUID;
  165.   LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
  166.   ArgErr: Pointer): HResult;
  167. var
  168.   V: OleVariant;
  169. begin
  170.   Result := S_OK;
  171.   case DispID of
  172.     1:
  173.       begin
  174.         // First parameter is new string
  175.         V := OleVariant(TDispParams(Params).rgvarg^[0]);
  176.         FController.OnServerMemoChanged(V);
  177.       end;
  178.     2: FController.OnClear;
  179.   end;
  180. end;
  181.  
  182. end.
  183.